perm filename CNVR.FMT[CMP,SYS] blob
sn#014785 filedate 1973-07-03 generic text, type T, neo UTF8
00100 (DEFUN DISPATCH
00200 (EXP1 RETAG SAVE ALINK1)
00300 (COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
00400 ((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
00500 (T (PROG (V F)
00600 (SETQ F (CAR EXP1))
00700 BEGIN(COND ((ATOM F)
00800 (COND ((SETQ V
00900 (GETL F
01000 (QUOTE (CINT CEXPR
01100 FEXPR
01200 FSUBR))))
01300 (GO (CAR V)))
01400 (T (SAVEUP)
01500 (SETQ UARGS (CDR EXP1)
01600 EARGS
01700 NIL)
01800 (RETURN (QUOTE EVARGS)))))
01900 ((EQ (CAR F) (QUOTE CLAMBDA))
02000 (SAVEUP)
02100 (BIND1 (QUOTE *BODY) (CDDR F))
02200 (SETQ VARS (CADR F) UARGS (CDR EXP1))
02300 (RETURN (QUOTE ARGB)))
02400 ((EQ (CAR F) (QUOTE LAMBDA))
02500 (SAVEUP)
02600 (SETQ UARGS (CDR EXP1) EARGS NIL)
02700 (RETURN (QUOTE EVARGS)))
02800 ((EQ (CAR F) (QUOTE *CLOSURE))
02900 (SETQ F (CADR F))
03000 (GO BEGIN))
03100 (T (SETQ F (CERR UNKNOWN
03200 FUNCTION
03300 TYPE
03400 ((QUOTE EXP1))))
03500 (GO BEGIN)))
03600 CINT (SAVEUP)
03700 (RETURN (CADR V))
03800 CEXPR(SAVEUP)
03900 (BIND1 (QUOTE *BODY) (CDADR V))
04000 (SETQ VARS (CAADR V) UARGS (CDR EXP1))
04100 (RETURN (QUOTE ARGB))
04200 FEXPR
04300 FSUBR(SETQ VAL (EVAL EXP1))
04400 (RETURN RETAG)))))
04500
00100 (DEFUN SAVEUP
00200 NIL
00300 (SETQ CLINK (CONS (CONS (SAVEV) RETAG)
00400 (COND ((NULL FRAME*)
00500 (SETQ CHALOBV NIL)
00600 (CONS (CONS BVARS ALINK)
00700 (CONS EXP CLINK)))
00800 (CHALOBV (SETQ CHALOBV NIL)
00900 (CONS (CONS BVARS ALINK)
01000 (CDDR FRAME*)))
01100 (T (CDR FRAME*))))
01200 EXP
01300 EXP1
01400 ALINK
01500 (COND ((EQ ALINK1 (QUOTE *TOP)) CLINK) (T ALINK1))
01600 BVARS
01700 NIL
01800 FRAME*
01900 NIL))
02000
02100 (DEFUN BIND1
02200 (VAR VAL)
02300 (SETQ BVARS (CONS (LIST VAR VAL) BVARS) CHALOBV T))
02400
02500 (DEFUN CLOSE
02600 NIL
02700 (COND ((ATOM (CAR EXP)))
02800 ((EQ (CAAR EXP) (QUOTE *CLOSURE))
02900 (SETQ ALINK (CADDAR EXP) CHALOBV T))))
03000
00100 (DEFUN OPTMATCH
00200 NIL
00300 (COND ((NULL UARGS)
00400 (CLOSE)
00500 (COND ((NULL VARS) (QUOTE AUXB)) (T (QUOTE FINVAR))))
00600 ((ATOM (CAR VARS))
00700 (COND ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
00800 (SETQ VARS (CDR VARS))
00900 (QUOTE OPTMATCH))
01000 ((EQ (CAR VARS) (QUOTE "REST"))
01100 (SETQ VARS (CDR VARS))
01200 (QUOTE RESTMATCH))
01300 (T (DISPATCH (CAR UARGS)
01400 (QUOTE OPTMATCH1)
01500 (QUOTE (VARS UARGS))
01600 ALINK))))
01700 ((EQ (CAAR VARS) (QUOTE QUOTE))
01800 (COND ((ATOM (CADAR VARS))
01900 (BIND1 (CADAR VARS) (CAR UARGS))
02000 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
02100 (QUOTE OPTMATCH))
02200 (T (CERR BAD DECLARATION))))
02300 ((ATOM (CAAR VARS)) (DISPATCH (CAR UARGS)
02400 (QUOTE OPTMATCH1)
02500 (QUOTE (VARS UARGS))
02600 ALINK))
02700 ((AND (EQ (CAAAR VARS) (QUOTE QUOTE))
02800 (ATOM (CADAAR VARS)))
02900 (BIND1 (CADAAR VARS) (CAR UARGS))
03000 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
03100 (QUOTE OPTMATCH))
03200 (T (CERR BAD DECLARATION))))
03300
03400 (DEFUN CONT1
03500 NIL
03600 (PROG NIL
03700 (SETQ TEM VAL)
03800 (RETURN (COND ((CDDR EXP) (DISPATCH (CADDR EXP)
03900 (QUOTE CONT2)
04000 (QUOTE (TEM))
04100 ALINK))
04200 (T (SETQ VAL NIL FRAME* (FR TEM))
04300 (RESTORE))))))
04400
00100 (DEFUN MATCH
00200 N
00300 ((LAMBDA (VARPAT DATAPAT)
00400 (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
00500 (COND ((> N 2) (SETQ MALIST1 (ARG 3)
00600 MALIST2
00700 (ARG 4)
00800 NOBIND
00900 T)))
01000 (SETQ MALISTV1 (GET (QUOTE MALIST1) (QUOTE VALUE))
01100 MALISTV2
01200 (GET (QUOTE MALIST2) (QUOTE VALUE)))
01300 (RETURN (COND ((MATCH1 VARPAT DATAPAT)
01400 (LIST MALIST1 MALIST2))))))
01500 (ARG 1)
01600 (ARG 2)))
01700
01800 (DEFUN TRYASSIGN
01900 N
02000 ((LAMBDA (VARS VAR PAT MALIST PALISTV VARSALLOWED RS)
02100 (COND (VARS (COND ((OR VARSALLOWED
02200 (NOT (HASMUSTASSIGNS VARS)))
02300 (COND ((HASVARS VARS))
02400 (T ((LAMBDA (VAL)
02500 (MSET VAR VAL MALIST)
02600 (SATISFY RS MALIST))
02700 (VARSUBST PAT
02800 (CDR PALISTV))))))))
02900 (T (MSET VAR PAT MALIST) (SATISFY RS MALIST))))
03000 (FINDVARS (ARG 2) (ARG 4))
03100 (ARG 1)
03200 (ARG 2)
03300 (ARG 3)
03400 (ARG 4)
03500 (ARG 5)
03600 (ARG 6)))
03700
00100 (DEFUN MAKE-METHOD
00200 (TYPE BOD)
00300 (PROG (FIRST OLDM CMARKERS)
00400 (COND ((ATOM (SETQ FIRST (CAR BOD)))
00500 (SETQ CMARKERS (COND ((SETQ OLDM
00600 (GET FIRST
00700 (QUOTE DATUM)))
00800 (CDR (CMARKERS OLDM)))))
00900 (PUTPROP FIRST
01000 (NCONC (LIST TYPE
01100 FIRST
01200 (CADR BOD)
01300 (CDDR BOD))
01400 CMARKERS)
01500 (QUOTE DATUM))
01600 (RETURN FIRST))
01700 (T (RETURN (LIST TYPE NIL FIRST (CDR BOD)))))))
01800
02000
02400
03500 ((RETURN NIL)))))
03600
00100 (DEFUN REVEAL
00200 (DATUM CON)
00300 (PROG (CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE
00400 NUM)
00500 (PI-OFF)
00600 (SETQ CMARKERS (ANALYZE DATUM))
00700 (SETQ CFRAMES (SETQ CON (CDR CON)))
00800 (SETQ CM (ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS))
00900 (SETQ CNUM (CADR CFRAME))
01000 (SETQ STATUS (CADR CM))
01100 (RPLACA (CDR CM) (QUOTE /+))
01200 (COND (STATUS (PI-ON) (RETURN NIL))
01300 ((AND PATTERN NEW (NULL (CDDR CMARKERS)))
01400 (INDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)))))
01500 (SETQ CMARKERS (CDDR CMARKERS))
01600 (SETQ CFRAMES (CDR CFRAMES))
01700 LOOP (COND ((SETQ CM (MFINTERSECT))
01800 (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
01900 (COND ((EQUAL CNUM NUM)
02000 (SETQ NEW NIL)
02100 (RPLACA (CDR CM)
02200 (OR (DELETE CNUM
02300 (CADR CM)
02400 1)
02500 (QUOTE /+))))))
02600 ((SETQ STATUS T)))
02700 (SETQ CMARKERS (CDR CMARKERS)
02800 CFRAMES
02900 (CDR CFRAMES))
03000 (GO LOOP))
03100 (NEW (RPLACD (CDR CFRAME)
03200 (CONS DATUM (CDDR CFRAME)))))
03300 (PI-ON)
03400 (RETURN (NOT STATUS))))
03500
00100 (DEFUN HIDE
00200 (DATUM CON)
00300 (PROG (PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD
00400 CFRAME CM)
00500 (SETQ CFRAMES (SETQ CON (CDR CON)))
00600 (SETQ CMARKERS (ANALYZE DATUM))
00700 (SETQ CNUM (CADAR CON))
00800 (PI-OFF)
00900 (COND ((SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES))
01000 (CDR CMARKERS)))
01100 (SETQ STATUS (CADR CM) OLD T)
01200 (COND ((CDDR CM) (RPLACA (CDR CM) NIL))
01300 ((SETQ REM T)
01400 (DELQ CM CMARKERS 1)
01500 (AND PATTERN
01600 (NULL (CDR CMARKERS))
01700 (UNINDEX DATUM
01800 PATTERN
01900 (GET TYPE (QUOTE *INDEX))
02000 (EQ TYPE (QUOTE ITEM))))))))
02100 (SETQ CMARKERS (CDR CMARKERS))
02200 LOOP (COND ((SETQ CM (MFINTERSECT))
02300 (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
02400 (COND (REM (SETQ REM (NOT (EQUAL CNUM
02500 NUM))))
02600 ((OR OLD
02700 (SETQ OLD (EQUAL CNUM NUM))))))
02800 ((SETQ REM NIL STATUS T) (CANCEL CM CNUM)))
02900 (SETQ CMARKERS (CDR CMARKERS)
03000 CFRAMES
03100 (CDR CFRAMES))
03200 (GO LOOP))
03300 (REM (RPLACD (CDR CFRAME)
03400 (DELQ DATUM (CDDR CFRAME) 1)))
03500 ((AND STATUS (NOT OLD))
03600 (RPLACD (CDR CFRAME)
03700 (CONS DATUM (CDDR CFRAME)))))
03800 (PI-ON)
03900 (RETURN STATUS)))
04000
04100 (DEFUN FINDCFRAME
04200 (CFRAME CMARKERS)
04300 (PROG (NF NM)
04400 (SETQ NF (CADR CFRAME))
04500 LOOP (COND ((NULL CMARKERS) (RETURN NIL))
04600 ((> NF (SETQ NM (CAAR CMARKERS))) (RETURN NIL))
04700 ((> NM NF) (SETQ CMARKERS (CDR CMARKERS))
04800 (GO LOOP))
04900 (T(RETURN (CAR CMARKERS))))))
05000
00100 (DEFUN MENTIONERS
00200 N
00300 (PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
00400 (COND ((< N 1) (TFA)))
00500 (SETQ CFRAMES (CDR (COND ((< N 3) (/, CONTEXT))
00600 ((= N 3) (ARG 3))
00700 ((TMA)))))
00800 (SETQ SIGN (COND ((> N 1) (ARG 2))))
00900 (SETQ CMARKERS (CDR (CMARKERS (ARG 1))))
01000 (SETQ CON CFRAMES)
01100 LOOP (COND ((SETQ CM (MFINTERSECT))
01200 (OR (AND SIGN (INVISIBLE (CADR CM) CON))
01300 (SETQ MENTIONERS (CONS (CAR CFRAMES)
01400 MENTIONERS)))
01500 (SETQ CFRAMES (CDR CFRAMES)
01600 CMARKERS
01700 (CDR CMARKERS))
01800 (GO LOOP)))
01900 (RETURN (REVERSE MENTIONERS))))
02000
02100 (DEFUN MFINTERSECT
02200 NIL
02300 (PROG (NM NF CM)
02400 ADVANCE
02500 (COND ((AND CMARKERS CFRAMES) (SETQ NF (CADAR CFRAMES)
02600 CM
02700 (CAR CMARKERS)
02800 NM
02900 (CAR CM)))
03000 ((RETURN NIL)))
03100 TEST (COND ((> NF NM)
03200 (OR (SETQ CFRAMES (CDR CFRAMES)) (RETURN NIL))
03300 (SETQ NF (CADAR CFRAMES))
03400 (GO TEST))
03500 ((> NM NF)
03600 (OR (SETQ CMARKERS (CDR CMARKERS)) (RETURN NIL))
03700 (SETQ CM (CAR CMARKERS) NM (CAR CM))
03800 (GO TEST))
03900 ((RETURN CM)))))
04000
00100 (DEFUN INVISIBLE
00200 (CNUMS CFRAMES)
00300 (AND (NOT (EQ CNUMS (QUOTE /+)))
00400 (OR (NULL CNUMS)
00500 (PROG (NC NF)
00600 (SETQ NC (CAR CNUMS))
00700 LOOP (COND (CFRAMES (SETQ NF (CADAR CFRAMES)
00800 CFRAMES
00900 (CDR CFRAMES)))
01000 ((RETURN NIL)))
01100 TEST (COND ((> NF NC) (GO LOOP))
01200 ((> NC NF) (OR (SETQ CNUMS (CDR CNUMS))
01300 (RETURN NIL))
01400 (SETQ NC (CAR CNUMS))
01500 (GO TEST))
01600 ((RETURN NC)))))))
01700